﻿#light

namespace CodeBlock

open System
open System.Linq

open Mono.Cecil
open Mono.Cecil.Cil

open RuntimeUtils
open Debug

type HighLevel()=
    let instantiate genericType typeParameter =
        debugln "TODO: instantiate"
        genericType
    
    let sizeof valueType =
        debugln "TODO: sizeof"
        8
    
    let nop = []
    
    [<OverloadID("typedef")>]
    member this.Morf (hltype: TypeReference): TypeDefinition=
        match hltype with
        | _ when hltype.FullName = "System.Object" ->
            let result = TypeDefinition(hltype.Name, hltype.Namespace,
                            TypeAttributes.AutoLayout ||| TypeAttributes.Public, null)
            
            let vmt = FieldDefinition(".VMT", TypeReference("IntPtr", "System", null, true),
                        FieldAttributes.Public ||| FieldAttributes.RTSpecialName ||| FieldAttributes.SpecialName)
            result.Fields.Add vmt
            
            result
        
        | _ when hltype.IsValueType ->
            downcast hltype
        
        | :? TypeDefinition ->
            let hltype = hltype :?> TypeDefinition
            if hltype.IsClass then
                let result = TypeDefinition(hltype.Name, hltype.Namespace,
                                TypeAttributes.AutoLayout ||| TypeAttributes.Public, null)
                
                result.IsValueType <- true
                
                let baseType = FieldDefinition(".Base", hltype.BaseType,
                                FieldAttributes.Public ||| FieldAttributes.RTSpecialName ||| FieldAttributes.SpecialName)
                result.Fields.Add baseType
                
                for field in hltype.Fields |> Seq.cast<FieldDefinition> |> Seq.filter (fun f -> not f.IsStatic) do
                    result.Fields.Add(field.Clone())
                
                result
            
            elif hltype.IsInterface then
                hltype
            
            else
                not_implemented "type morfing" |> raise
            
        | _ ->
            not_implemented "type morfing" |> raise
    
    [<OverloadID("methoddef")>]
    member this.Morf (hlmethod: MethodDefinition)=
        let result = MethodDefinition(hlmethod.Name, MethodAttributes.Static, this.Morf hlmethod.ReturnType.ReturnType)
        
        if hlmethod.HasThis then
            let thisParam = ParameterDefinition(this.Morf hlmethod.DeclaringType)
            debugln "TODO: make a reference"
            result.Parameters.Add thisParam
        
        for hlparam in hlmethod.Parameters do
            let param = ParameterDefinition(this.Morf hlparam.ParameterType)
            param.Name <- hlparam.Name
            param.IsIn <- hlparam.IsIn
            param.IsOut <- hlparam.IsOut
            param.IsOptional <- hlparam.IsOptional
            result.Parameters.Add(param)
        
        for hlvar in hlmethod.Body.Variables do
            let var = VariableDefinition(this.Morf hlvar.VariableType)
            var.Index <- hlvar.Index
            var.Name <- hlvar.Name
            result.Body.Variables.Add(var)
        
        let cil = result.Body.CilWorker
        
        let swap =
            debugln "TODO: swap"
            []
        
        let stfld (field: FieldReference) =
            cil.Create(OpCodes.Stfld, field) :: []
        
        let ldfld (field: FieldReference) =
            cil.Create(OpCodes.Ldfld, field) :: []
        
        let ldflda (field: FieldReference) =
            cil.Create(OpCodes.Ldflda, field) :: []
        
        /// <summary>
        /// Code to allocate object instance and set it's VMT pointer.
        /// Result type is pointer to memory.
        /// </summary>
        let initobj objtype =
            let size = sizeof objtype
            GC.Alloc size @ VirtualMethodTable.Address objtype @ stfld VirtualMethodTable.Field
            
        let box (targetType: TypeDefinition) =
            debugln "TODO: support System.Nullable"
            debugln "TODO: check if it is correct for interfaces"
            debugln "TODO: all types are taken in account?"
            if not targetType.IsValueType then
                []
            else
                // CliCore!.Box<targetType>
                let boxType = instantiate Box.Type targetType
                initobj boxType @ swap @ stfld Box.ValueField
            
        
        let callvirt target =
            []
        
        let castclass targetClass =
            []
        
        let cpobj targetType = 
            []
        
        let initobj targetType =
            []
        
        let isinst targetType =
            []
        
        let ldelem itemType =
            []
        
        let ldelema itemType =
            []
        
        let ldlen =
            []
        
        let ldobj targetType=
            []
        
        let ldsfld field =
            []
        
        let ldsflda field =
            []
        
        let ldstr str =
            []
        
        let ldtoken token =
            []
        
        let ldvirtfn target =
            []
        
        let mkrefany targetType =
            []
        
        let newarr itemType =
            []
        
        let newobj ctor =
            []
        
        let refanytype() =
            []
        
        let refanyval targetType =
            []
        
        let rethrow() =
            []
        
        let sizeof targetType =
            []
        
        let stelem itemType =
            []
        
        let stobj targetType =
            []
        
        let stsfld field =
            []
        
        let throw() =
            []
        
        let unbox valueType =
            []
        
        let unboxAny targetType =
            []
        
        let morf (instruction: Instruction) =
            match instruction.OpCode.Code with
            | Code.Ldfld ->
                ldfld (instruction.Operand :?> FieldReference)
            | Code.Stfld ->
                stfld (instruction.Operand :?> FieldReference)
            | Code.Callvirt ->
                callvirt (instruction.Operand)
            | Code.Castclass ->
                castclass instruction.Operand
            | Code.Cpobj ->
                cpobj instruction.Operand
            | Code.Initobj ->
                initobj instruction.Operand
            | Code.Isinst ->
                initobj instruction.Operand
            | Code.Ldelem_Any ->
                InvalidProgramException("// opcode 163") |> raise
                ldelem instruction.Operand
            | Code.Ldelema ->
                ldelema instruction.Operand
            | Code.Ldflda ->
                ldflda (instruction.Operand :?> FieldReference)
            | Code.Ldlen ->
                ldlen
            | Code.Ldobj ->
                ldobj instruction.Operand
            | Code.Ldsfld ->
                ldsfld instruction.Operand
            | Code.Ldsflda ->
                ldsflda instruction.Operand
            | Code.Ldstr ->
                ldstr instruction.Operand
            | Code.Ldtoken ->
                ldtoken instruction.Operand
            | Code.Ldvirtftn ->
                ldvirtfn instruction.Operand
            | Code.Mkrefany ->
                mkrefany instruction.Operand
            | Code.Newarr ->
                newarr instruction.Operand
            | Code.Newobj ->
                newobj instruction.Operand
            | Code.Refanytype ->
                refanytype()
            | Code.Refanyval ->
                refanyval instruction.Operand
            | Code.Rethrow ->
                rethrow()
            | Code.Sizeof ->
                sizeof instruction.Operand
            | Code.Stelem_Any ->
                InvalidProgramException("// opcode 164") |> raise
                stelem instruction.Operand
            | Code.Stobj ->
                stobj instruction.Operand
            | Code.Stsfld ->
                stsfld instruction.Operand
            | Code.Throw ->
                throw()
            | Code.Unbox ->
                unbox instruction.Operand
            | Code.Unbox_Any ->
                unboxAny instruction.Operand
            | _ ->
                instruction :: []
        
        for hlinstr in hlmethod.Body.Instructions do
            for instr in morf hlinstr do
                result.Body.CilWorker.Append instr
        
        result
